(in-package :user)

;;----------------------------------------------------------------------
;; PSEUDO-UNIFY.LISP -- Version of Tomita's GLR unification without
;;                      the GLR parser code.
;;----------------------------------------------------------------------
;; 10-Apr-97 by EHN -- Extracted  functions from v8-4-rt.lisp

;;----------------------------------------------------------------------
;; CONSTANTS.

;; defconstant CONSTIT-LIST 

(defconstant CONSTIT-LIST 
  '(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
       x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
       x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
       x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

;;----------------------------------------------------------------------
;; VARIABLES.

;; defvar *register-bag*

(defvar *register-bag*)

;; defvar *user-defined-equation* nil)

(defvar *user-defined-equation* nil)

;;----------------------------------------------------------------------
;; MACROS.

;; defmacro multi-p (fs)

(defmacro multi-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*MULTIPLE*)))

;; defmacro or-p (fs)

(defmacro or-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*OR*)))

;; defmacro not-p (fs)

(defmacro not-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*NOT*)))

;; defmacro user-p (fs)

(defmacro user-p (fs)
  `(and (not (atom ,fs))(atom (car ,fs))))

;; defmacro append-dolist (varlist body)

(defmacro append-dolist (varlist body)
  (let ((append-result (gensym)))
    `(let ((,append-result nil))
       (dolist ,varlist 
	       (setq ,append-result (append ,body ,append-result)))
       ,append-result)))

;; defmacro map-dolist (varlist body)

(defmacro map-dolist (varlist body)
  (let ((map-result (gensym)))
    `(let ((,map-result nil))
       (dolist ,varlist (push ,body ,map-result))
       (nreverse ,map-result))))

;; defmacro map-dolist+ (varlist body)

(defmacro map-dolist+ (varlist body)
  `(remove '*FAIL* (map-dolist ,varlist ,body)))

;; defmacro and-dolist (varlist body)

(defmacro and-dolist (varlist body)
  (let ((result (gensym)))
    `(let ((,result nil))
       (dolist ,varlist
	       (setq ,result ,body)
	       (if (null ,result) (return nil)))
       ,result)))

;; defmacro or-dolist (varlist body)

(defmacro or-dolist (varlist body)
  (let ((result (gensym)))
    `(let ((,result nil))
       (dolist ,varlist
	       (setq ,result ,body)
	       (if ,result (return ,result))))))

;; defmacro p=p (path1 path2)
;; defmacro p=d (path)
;; defmacro p=u (path)
;; defmacro p=r (path)
;; defmacro p=a (path atom)
;; defmacro p=ca (path atom)
;; defmacro p>p (path1 path2)
;; defmacro p>a (path atom)
;; defmacro p=l (path lispcode)
;; defmacro p>p (path1 path2)
;; defmacro p<p (path1 path2)
;; defmacro p<a (path atom)

(defmacro p=p (path1 path2)
  `(setq x (path=path x ',path1 ',path2)))
(defmacro p=a (path atom)
  `(setq x (path=atom x ',path ',atom)))
(defmacro p=d (path)
  `(setq x (path=defined x ',path)))
(defmacro p=u (path)
  `(setq x (path=undefined x ',path)))
(defmacro p=r (path)
  `(setq x (path=remove x ',path)))
(defmacro p=ca (path atom)
  `(setq x (path=catom x ',path ',atom)))
(defmacro p>p (path1 path2)
  `(setq x (path>path x ',path1 ',path2)))
(defmacro p>a (path atom)
  `(setq x (path>atom x ',path ',atom)))
(defmacro p=l (path lispcode)
  `(setq x (path=lispcode x ',path ',lispcode)))
(defmacro p==p (path1 path2)
  `(setq x (path=remove
		(path=path (path=defined x ',path2) ',path1 ',path2)
	        ',path2)))
(defmacro p<p (path1 path2)
  `(setq x (path<path x ',path1 ',path2)))
(defmacro p<a (path atom)
  ;; NOTE -- PATH<ATOM NOT DEFINED!
  `(setq x (path<atom x ',path ',atom)))

;;----------------------------------------------------------------------
;; FUNCTIONS.

;; defun unify (fs1 fs2) ; returns a fs or *fail*

(defun unify (fs1 fs2)			; returns a fs or *fail*
  (cond ((null fs1) fs2)
	((null fs2) fs1)
 	((multi-p fs1) (unify*multiple* fs1 fs2))
 	((multi-p fs2) (unify*multiple* fs2 fs1))
	((or-p fs1) (unify*OR* fs1 fs2))
	((or-p fs2) (unify*OR* fs2 fs1))
	((not-p fs1) (unify*NOT* fs1 fs2))
	((not-p fs2) (unify*NOT* fs2 fs1))
     	((user-p fs1)(unify-user-values fs1 fs2))
	((user-p fs2)(unify-user-values fs2 fs1))
	((atom fs1) (if (equal fs1 fs2) fs2 '*fail*))
	((atom fs2) '*fail*)
	(t (unify-fs fs1 fs2))))

;; defun unify-fs (fs1 fs2)  ; returns a new fs

(defun unify-fs (fs1 fs2)		; returns a new fs
  (prog (new-fs sub-fs)
	(dolist (slot-value fs1)
		(let* ((slot (car slot-value))
		       (value (second slot-value))
		       (assoc-result (assoc slot fs2)))
		  (cond (assoc-result 
			 (setq sub-fs (unify value (second assoc-result)))
			 (if (eq sub-fs '*fail*) (return-from unify-fs '*fail*))
			 (push (list slot sub-fs) new-fs)
			 (setq fs2 (remove assoc-result fs2)))
			(t
			 (push slot-value new-fs)))))
	(return (append new-fs fs2))))

;; defun unify*multiple* (fs1 fs2 &aux result)

(defun unify*multiple* (fs1 fs2 &aux result)
  (setq result
	(append-dolist (f (cdr fs1))
		       (multi-value-to-list (unify f fs2))))
  (if (member '*fail* result) 
      '*fail* 
    (list-to-multi-value result)))

;; defun unify*or* (fs1 fs2 &aux result)

(defun unify*or* (fs1 fs2 &aux result)
  (setq result
	(append-dolist (f (cdr fs1))
		       (value-to-list (unify f fs2))))
  (setq result (remove '*fail* result))
  (if result 
      (list-to-value result) 
    '*fail*))

;; defun unify*not* (fs1 fs2 &aux result)

(defun unify*not* (fs1 fs2 &aux result)
  (cond
   ((not-p fs2)
    (cons '*NOT* (union (cdr fs1) (cdr fs2) :test #'equal)))
   (t 
    (setq result
	  (append-dolist (f (cdr fs1))
			 (value-to-list (unify f fs2))))
    (setq result (remove '*FAIL* result))
    (if result '*FAIL* fs2))))

;; defun unify-user-values (fs1 fs2)

(defun unify-user-values (fs1 fs2)
  (apply (intern (concatenate 'string "UNIFY"
			      (symbol-name (car fs1))))
	 (list fs1 fs2)))

;; defun value-to-list (v)

(defun value-to-list (v)
  (cond ((null v) nil)
	((atom v)(list v))
	((eq (car v) '*OR*)(cdr v))
        (t (list v))))

;; defun list-to-value (v-list)

(defun list-to-value (v-list)
  (cond ((null v-list) nil)
	((eq (length v-list) 1)(car v-list))
	(t (cons '*OR* v-list))))

;; defun multi-value-to-list (v)

(defun multi-value-to-list (v)
  (cond ((null v) nil)
	((atom v)(list v))
	((eq (car v) '*MULTIPLE*)(cdr v))
        (t (list v))))

;; defun list-to-multi-value (v-list)

(defun list-to-multi-value (v-list)
  (cond ((null v-list) nil)
	((eq (length v-list) 1)(car v-list))
	(t (cons '*MULTIPLE* v-list))))

;; defun compile-augmentation (rhs-len statements)

(defun compile-augmentation (rhs-len statements)
  (declare (fixnum rhs-len))
  (let* ((reg-list            (subseq CONSTIT-LIST 1 (1+ rhs-len)))
	 (compiled-statements (compile-statements statements))
	 (used-regs           (collect-registers compiled-statements))
	 (not-used-regs       (set-difference reg-list used-regs))
	 (cons-list           (make-cons-list used-regs)))
    (append
     `(lambda ,reg-list)
     (when not-used-regs		; if there is registers for no use
	   `((declare (ignore ,@not-used-regs))))
     `((let ((x (list (list ,@cons-list))))
	 (and ,compiled-statements
	      (or (getvalue* x '(x0)) t)))))))

;; defun compile-statements (statements)

(defun compile-statements (statements)
  `(and
    ,@(map-dolist (statement statements)
		  (compile-statement statement))))

;; defun compile-statement (statement)

(defun compile-statement (statement)
  (let ((part1 (first  statement))
	(part2 (second statement))
	(part3 (third  statement)))
					; 
					;   If it is a disjunctive statement
					; 
    (cond ((eq part1 '*OR*)
	   `(setq x
		  (append
		   ,@(map-dolist (s (rest statement))
				 `(let ((x x))
				    ,(compile-statements s))))))
					; 
					;   If it is an exclusive OR statement
					; 
          ((eq part1 '*EOR*)
	   `(setq x
		  (append-dolist (fs x)
				 (or
				  ,@(map-dolist (s (rest statement))
						`(let ((x (list fs)))
						   ,(compile-statements s)))))))
					; 
					;   If it is an CASE statement
					; 
          ((eq part1 '*CASE*)
	   `(setq x
		  (append-dolist (fs x)
				 (case ,(compile-lispcode part2)
				       ,@(map-dolist (s (cddr statement))
						     `(,(car s) (let ((x (list fs)))
								  ,(compile-statements (cdr s)))))))))
					; 
					;   If it is a TEST statement	;  need to change to unpack.
					; 
          ((eq part1 '*TEST*)
	   `(let ()
	      (setq x
		    (append-dolist (getpath ',(find-paths part2))
				   (completely-unpack* x getpath)))
	      (setq x
		    (append-dolist (fs x)
				   (and ,(compile-lispcode part2) (list fs))))))
					; 
					;   If it is an INTERPRET statement ; need to change to unpack.
					; 
	  ((eq part1 '*INTERPRET*)
	   `(setq x
		  (append-dolist (fs x)
				 (interpret-statements (list fs)
						       (apply '(lambda (fs) ,(compile-lispcode part2))
							      (list fs))))))
					; 
					;   If length of statement is 3 and part1 is a path, then equation.
					; 
	  ((= (length statement) 3)
           (compile-equation statement))
					; 
					;   Otherwise, error.
					; 
          (t (equation-error statement)))))

;; defun collect-registers (form)

(defun collect-registers (form)
  (setq *register-bag* nil)
  (collect-registers-sub form)
  *register-bag*)

;; defun collect-registers-sub (form)

(defun collect-registers-sub (form)
  (if (atom form)
      (when (and (registerp form)
		 (not (eq form 'x0)))
	    (pushnew form *register-bag*))
    (dolist (f form)
	    (collect-registers-sub f))))

;; defun registerp (x)

(defun registerp (x)
   (member x CONSTIT-LIST))

;; defun make-cons-list (reg-list)

(defun make-cons-list (reg-list)
  (mapcar #'(lambda (reg) `(list (quote ,reg) ,reg)) reg-list))

;; defun getvalue* (fs-list path)

(defun getvalue* (fs-list path)
    (list-to-value   
	(append-dolist (fs fs-list)
	   (value-to-list (getvalue fs path)))))

;; defun getvalue (fs path)   ; returns a fs; or nil if undefined

(defun getvalue (fs path)		; returns a fs; or nil if undefined
  (cond ((not (listp fs)) nil)
	(t (let ((assoc-result (second (assoc (car path) fs))))
	     (cond 
	      ;; if assoc-result is nil, return nil
	      ((null assoc-result) nil)
	      ;; if path length is 1, return assoc-result
	      ((eq (length path) 1) assoc-result)
	      ;; otherwise call getvalue recursively
	      (t (getvalue assoc-result (cdr path))))))))

;; defun compile-lispcode (expr)

(defun compile-lispcode (expr)
  (cond ((atom expr) expr)
	((eq 'QUOTE (car expr)) expr)
	((pathp expr) `(getvalue fs ',expr))
	(t (map-dolist (e expr) (compile-lispcode e)))))

;; defun find-paths (expr)

(defun find-paths (expr)
  (cond ((atom expr) nil)
	((eq 'QUOTE (car expr)) nil)
	((pathp expr) (list expr))
	(t (mapcan #'(lambda (sub-expr) (find-paths sub-expr))
		   expr))))

;; defun resisterp (x)

(defun resisterp (x)
  (member x CONSTIT-LIST))

;; defun pathp (x)

(defun pathp (x)
  (and (listp x) (resisterp (car x))))

;; defun completely-unpack* (fs-list path)

(defun completely-unpack* (fs-list path)
  (unpack* fs-list (append path '(DUMMY))))

;; defun unpack* (fs-list path)

(defun unpack* (fs-list path)
  (append-dolist (fs fs-list)
		 (let ((result (unpack fs path)))
		   (if (eq result '*fail*) 
		       (return-from unpack* '*fail*) 
		     result))))

;; defun unpack (fs path)			; returns a fs-list or *FAIL*

(defun unpack (fs path)			; returns a fs-list or *FAIL*
  (prog (sub-fs unpacked-sub-fs-list)
	;; if (length path) is 1, no need to unpack
	(if (equal (length path) 1) (return (value-to-list fs)))
	;; if fs is a *MULTIPLE* value, fail.				 
  	(if (eq (car fs) '*MULTIPLE*) (return '*fail*))
	;; get sub f-structure
	(setq sub-fs (second (assoc (car path) fs)))
	;; if sub-fs is undefined, no need to unpack
	(if (null sub-fs) (return (list fs)))
	(if (not (listp sub-fs)) (return (list fs)));;tomabech

	(setq unpacked-sub-fs-list
	      (cond
	       ;; if sub-fs is a *OR* list
	       ((eq (car sub-fs) '*OR*)
		(append-dolist (sub-fs-1 (cdr sub-fs))
			       (let ((result (unpack sub-fs-1 (cdr path))))
				 (if (eq result '*fail*)
				     (return-from unpack '*fail*)
				   result))))
	       ;; if sub-fs is a *MULTIPLE* value
	       ((eq (car sub-fs) '*MULTIPLE*)
		(return-from unpack '*fail*))
	       ;; if sub-fs is a single value
	       (t
		(unpack sub-fs (cdr path)))))
	(return
	 (map-dolist (unpacked-sub-fs unpacked-sub-fs-list)
		     (setvalue fs (list (car path)) unpacked-sub-fs)))))

;; defun setvalue (fs path val &key (mode 'OVERWRITE))  ; returns a fs

(defun setvalue (fs path val &key (mode 'OVERWRITE)) ; returns a fs
  (cond
   ((null path)
    (case mode
	  (OVERWRITE val)
   	  (UNIFY (unify fs val))
	  (C-UNIFY (if fs (unify fs val) '*FAIL*))
	  (DEFINED (if fs fs '*FAIL*)) 
	  (UNDEFINED (if fs '*FAIL* nil))
	  (PUSH (append-fs-to-fs fs val))
	  (REMOVE nil)
	  (POP (pop-multi-value fs))))

   ;; if fs is *OR*, do each of the disjunction.
   ;; Return *fail* when all of the disjunction fail.
   ((and (listp fs)(eq (car fs) '*OR*))
    (or
     (list-to-value
      (map-dolist+ (fs1 (cdr fs))
		   (setvalue fs1 path val :mode mode)))
     '*FAIL*))

   ;; if fs is *MULTIPLE*, do each of the conjunction.
   ;; Return *fail* when any one of the disjunction fails.
   ((and (listp fs)(eq (car fs) '*MULTIPLE*))
    (let ((newvalue nil))
      (setq newvalue
	    (map-dolist (fs1 (cdr fs))
			(setvalue fs1 path val :mode mode)))
      (if (member '*FAIL* newvalue)
	  '*FAIL*
	(cons '*MULTIPLE* newvalue))))
          
   ;; else take ASSOC
   (t (let ((assoc-result (assoc (car path) fs)))
	(if
            (null assoc-result)
	    ;; If the path doesn't exist	
	    (case mode
		  ((OVERWRITE UNIFY PUSH) (append (create-path path val) fs))
		  ((C-UNIFY DEFINED) '*FAIL*)
		  ((UNDEFINED REMOVE) fs))
	      
	  ;; If the path exists, call setvalue recursively
	  (let ((rec-result (setvalue (second assoc-result)
				      (cdr path) val :mode mode)))
	    (cond ((eq rec-result '*FAIL*) '*FAIL*)
		  ((null rec-result)(remove assoc-result fs))
		  ((cons (list (car path) rec-result)
			 (remove assoc-result fs))))))))))

;; defun create-path (path val)

(defun create-path (path val)
  (cond ((= (length path) 1)
	 (list (list (car path) val)))
	(t (list (list (car path)
		       (create-path (cdr path) val))))))

;; defun pop-multi-value (v)

(defun pop-multi-value (v)
  (setq v (multi-value-to-list v))
  (if (null v) '*FAIL*
    (list-to-multi-value (cdr v))))

;; defun append-fs-to-fs (fs1 fs2)

(defun append-fs-to-fs (fs1 fs2)
  (cond ((null fs1) fs2)
	((multi-p fs1)
	 (cond ((null fs2) fs1)
	       ((multi-p fs2) (cons '*MULTIPLE*
				    (cons (cdr fs2) (cdr fs1))))
	       (t (cons '*MULTIPLE* (cons fs2 (cdr fs1))))))
	(t
	 (cond ((multi-p fs2) (cons '*MULTIPLE* 
				    (cons fs2 (cdr fs1))))
	       (t (list '*MULTIPLE* fs2 fs1))))))

;; defun interpret-statements (x statements)

(defun interpret-statements (x statements)
  (and-dolist (statement statements)
	(setq x (interpret-statement x statement))))

;; defun interpret-statement (x statement)

(defun interpret-statement (x statement)
  (let ((part1 (first statement))
	(part2 (second statement))
    	(part3 (third statement)))
					; 
					;   If it is a disjunctive statement
					; 
    (cond ((eq part1 '*OR*)
	   (setq x
		 (append-dolist (s (rest statement))
				(interpret-statements x s))))
					; 
					;   If it is an exclusive OR statement
					; 
          ((eq part1 '*EOR*)
	   (setq x
		 (append-dolist (fs x)
				(or-dolist (s (rest statement))
					   (interpret-statements (list fs) s)))))
					; 
					;   If it is an CASE statement
					; 
          ((eq part1 '*CASE*)
	   (append-dolist (fs x)
			  (let ((key (interpret-lispcode fs part2)))
			    (interpret-statements (list fs)
						  (cdr (assoc key (cddr statement))))
			    )))
					; 
					;   If it is an exclusive TEST statement
					; 
          ((eq part1 '*TEST*)
           (setq x 
		 (append-dolist (getpath (find-paths part2))
				(completely-unpack* x getpath)))
           (append-dolist (fs x)
			  (and (interpret-lispcode fs part2) (list fs))))

;;;   If it is a recursive evaluation of equations
;;; 
	  ((eq part1 '*INTERPRET*)
           (append-dolist (fs x)
			  (interpret-statements
			   (list fs) (interpret-lispcode fs part2))))

					; 
					;   If length of statement is 3 and part1 is a path, then equation.
					; 
	  ((= (length statement) 3)
           (interpret-equation x statement))
					; 
					;   Otherwise, error.
					; 
          (t (equation-error statement)))))

;; defun interpret-equation (x equation)

(defun interpret-equation (x equation)
  (apply `(lambda (x) ,(compile-equation equation)) (list x)))

;; defun interpret-lispcode (fs expr)

(defun interpret-lispcode (fs expr)
  (apply `(lambda (fs) ,(compile-lispcode expr)) (list fs)))

;; defun compile-equation (equation)

(defun compile-equation (equation)
  (let ((part1 (first  equation))
	(part2 (second equation))
	(part3 (third  equation)))
					; 
					;   Xn  -->  (Xn)
					;
    (if (resisterp part1) (setq part1 (list part1)))
    (if (resisterp part3) (setq part3 (list part3)))

					; 
					;   Branch by part2
					; 
    (case part2
	  (=
	   (cond ((pathp part3)
		  `(P=P ,part1 ,part3))
		 ((eq part3 '*DEFINED*)
		  `(P=D ,part1))
		 ((eq part3 '*UNDEFINED*)
		  `(P=U ,part1))
		 ((eq part3 '*REMOVE*)
		  `(P=R ,part1))
		 ((or (atom part3) (atom (car part3)))
		  `(P=A ,part1 ,part3))
		 (t (equation-error equation))))

	  (=c
	   (cond ((pathp part3)
		  (equation-error equation))
		 ((or (atom part3) (atom (car part3)))
		  `(P=CA ,part1 ,part3))
		 (t (equation-error equation))))

	  (>
	   (cond ((pathp part3)
		  `(P>P ,part1 ,part3))
		 ((or (atom part3) (atom (car part3)))
		  `(P>A ,part1 ,part3))
		 (t (equation-error equation))))

	  (<=
	   `(P=L ,part1 ,part3))

	  (==
	   (cond ((pathp part3)
		  `(P==P ,part1 ,part3))
		 (t (equation-error equation))))

	  (<
	   (cond ((pathp part3)
		  `(P<P ,part1 ,part3))
		 ((or (atom part3) (atom (car part3)))
		  `(P<A ,part1 ,part3))
		 (t (equation-error equation))))
	  (t
	   (cond ((member part2 *user-defined-equation*)
		  (compile-statements
		   (macroexpand (list part2 part1 part3))))
		 (t (equation-error equation)))))))

;; defun equation-error (object)

(defun equation-error (object)
  (format t "~%### INVALID EQUATION ~S~%" object)
  nil)

;; defun path=path (*fs-list* path1 path2 &aux unpacked)

(defun path=path (*fs-list* path1 path2 &aux unpacked)
  ;; unpack all f-structures so we won't have to worry about
  ;; disjunction during unification
  (setq unpacked (unpack* *fs-list* path2))
  ;; Unpack path2. If it fails due to *MULTIPLE*, try unpack path1.
  ;; If both unpackings fail, error.
  (cond ((eq unpacked '*fail*)
	 (setq unpacked (unpack* *fs-list* path1))
	 (cond ((eq unpacked '*fail*)
		(format t "### (~S = ~S). Both contain *MUTLIPLE*."
			path1 path2)
		(return-from path=path nil))
	       (t
		(map-dolist+ (fs unpacked)
			     (setvalue fs path2 (getvalue fs path1) :mode 'UNIFY))
		)))
	(t 
	 (map-dolist+ (fs unpacked)
		      (setvalue fs path1 (getvalue fs path2) :mode 'UNIFY)))))

;; defun path=defined (*fs-list* path)

(defun path=defined (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'DEFINED)))

;; defun path=undefined (*fs-list* path)

(defun path=undefined (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'UNDEFINED)))

;; defun path=remove (*fs-list* path)

(defun path=remove (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'REMOVE)))

;; defun path=atom (*fs-list* path atom)

(defun path=atom (*fs-list* path atom)
  ;; Do unification and set the result
  (map-dolist+ (fs *fs-list*)
	       (setvalue fs path atom :mode 'UNIFY)))

;; defun path=catom (*fs-list* path atom)

(defun path=catom (*fs-list* path atom)
  (map-dolist+ (fs *fs-list*)
	       (setvalue fs path atom :mode 'C-UNIFY)))

;; defun path>path (*fs-list* path1 path2 &aux unpacked)

(defun path>path (*fs-list* path1 path2 &aux unpacked)
  (setq unpacked (unpack* *fs-list* path2))
  (cond ((eq unpacked '*fail*)
	 (format t "### (~S > ~S).  Thr right path contains *MULTIPLE*"
		 path1 path2)
	 (return-from path>path nil)))
  (map-dolist+ (fs unpacked)
	       (setvalue fs path1 (getvalue fs path2) :mode 'PUSH)))

;; defun path>atom (*fs-list* path atom)

(defun path>atom (*fs-list* path atom)
  (map-dolist+ (fs *fs-list*)
	       (setvalue fs path atom :mode 'PUSH)))

;; defun path=lispcode (*fs-list* path expr)

(defun path=lispcode (*fs-list* path expr)
 
  ;; Unpack for all paths in the lisp code (EXPR) 
  (dolist (getpath (find-paths expr))
	  (setq *fs-list* (unpack* *fs-list* getpath)))

  ;;  Then GETVALUE all paths, apply the lisp code, and SETVALUE
  ;;  the result into PATH.
  ;;  Example: (setvalue fs '(x0) (+ (getvalue fs '(x2 value))
  ;;					(* 10 (getvalue fs '(x1 value)))))
     
  (map-dolist (fs *fs-list*)
	      (setvalue fs path (apply `(lambda (fs) ,(compile-lispcode expr))
				       (list fs)))))

;; defun path<path (*fs-list* path1 path2 &aux unpacked)

(defun path<path (*fs-list* path1 path2 &aux unpacked)
  (setq unpacked (unpack* *fs-list* path2))
  (cond ((eq unpacked '*fail*)
	 (format t "### (~S < ~S).  Thr right path contains *MULTIPLE*"
		 path1 path2)
	 (return-from path<path nil)))
  (map-dolist+ (fs unpacked)
	       (let ((value (multi-value-to-list (getvalue fs path2))))
		 (cond ((null value)
			(return-from path<path nil))
		       (t 
			(setq fs (setvalue fs path1 (car value) :mode 'UNIFY))
			(setvalue fs path2 nil :mode 'POP)
			)))))

;; defun path<path (?) -- UNDEFINED!! 

;; EOF
